c -h- nextel.fms	Tue Sep  2 10:58:55 1986	
	SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C  SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
C  THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
C  BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
C  NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
C
C  RETCD  =	1  IF OPERAND (VALUE IN RETVAL(100)
C		2  IF OPERATOR (VALUE IN RETTYP)
C		3  NO MORE ELEMENTS
C		4  IF ERROR
C
C  RETVAL  HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
C	   A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
C
C  RETTYP  IS THE TYPE CODE
C NEXTEL CALLS
C
C ERRMSG     PRINTS OUT ERROR MESSAGES
C FLIP       REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
C GETNNB     GETS THE NEXT NON-BLANK FROM LINE(80)
C
C NEXTEL IS CALLED BY INPOST
C
C
C    VARIABLE    USE
C    ---------   ----------------------------------
C
C    ALPHA(27)   HOLDS LEGAL VARIABLE NAMES.
C
C    ARROW       '^'
C
C    B10         SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
C                DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
C
C    B16         SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
C                DIGIT A, B, C, D, E, OR F WAS FOUND.
C
C    BASE        HOLDS BASE OF CONSTANT.
C
C    CHAR1       HOLDS A SINGLE CHARACTER FROM LINE.
C
C    DEFBAS      THE DEFAULT BASE SPECIFIED.
C
C    DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
C                 8, 10, AND 16.
C
C    DOT          '.'
C
C    EQ           '='
C
C    EXCODE       CODE FOR EXPONENTIATION.
C
C    FCNT         NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
C
C    FUNCT (NAME,INDXX) HOLDS FUNCTION NAMES.
C
C    FUNVAL(I,J)
C     IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
C             FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
C     IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
C             FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
C
C
C    I,J,K,L  HOLDS TEMPORARY VALUES
C
C    I1,I2    HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
C
C    IALPHA   INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
C
C    IHOLD    HOLDS TEMPORARY VALUES
C
C    INT      PICKS UP INTEGER*4 VALUES.
C
C    IPT      POINTER TO ELEMENTS IN LINE(80).
C
C    IPT2     POINTER TO ELEMENTS IN LINE(80).
C
C    LASTOP  USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
C            CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
C
C    MINUS   '-'
C
C    OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
C
C    PLUS    '+'
C
C    QUOTE   "'"
C
C    RB      HOLDS NEGATIVE POWERS OF 10.(BASE 10)
C
C    REAL    PICKS UP REAL*8 CONSTANTS.
C
C    RETCD   RETURN CODE:
C              1 IF OPERAND (VALUE IN RETVAL(100))
C              2 IF OPERATOR (VALUE IN RETTYP)
C              3 NO MORE ELEMENTS.
C              4 IF ERROR.
C
C    RETCD2  RETURN CODE WHEN CALLING GETNNB.
C
C    RETPT   INDEXES DIGITS PICKED UP FOR A CONSTANT.
C
C    RETTYP  THE TYPE CODE OF THE RETURNED ELEMENT.
C
C    TYPE    TYPE CODE FOR EACH VARIABLE.
C
C    VBLS    HOLDS VALUE OF VARIABLES.
C
C    VLEN    GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
C
C LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION
C
C
	REAL*8 REAL,RB,ACX,XAC
	INTEGER*4 INT
	EXTERNAL INDX,DFLOAT
	REAL*8 DFLOAT
	InTeGer*4 INDXX
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 LASTOP
	InTeGer*4 VIEWSW,BASED,VLEN(9),DEFBAS
	InTeGer*4 TYPE(1,1)
	InTeGer*4 RETCD,RETCD2,RETTYP,EXCODE
	InTeGer*4 B10,B16,RETPT,BASE
	InTeGer*4 FCNT,AHOLD
	InTeGer*4 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
C
	CHARACTER*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
	CHARACTER*1 RETVAL(20)
C	REAL*8 RVLF
C	EQUIVALENCE (FVLF,RETVAL(1))
	CHARACTER*1 FUNCT(10,40)
	InTeGer*4   FUNVAL(2,40)
	CHARACTER*1 AVBLS(20,27)
	EQUIVALENCE(XAC,AVBLS(1,27))
	CHARACTER*1 VBLS(8,1,1)
	CHARACTER*1 OPER(9),DIGITS(16,3)
	CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 FOUR(4),EIGHT(8)
C
	COMMON /V/ TYPE,AVBLS,VBLS,VLEN
	COMMON /DIGV/ DIGITS
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
c	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC	COMMON /ERROR/ LASTOP
C
	EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
C
	DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
	DATA MINUS/'-'/,PLUS/'+'/
	DATA OPER/'(','-','!','*','/','+','-',')','='/
C
C  NUMBER OF FUNCTIONS
	DATA FCNT/30/
C
	DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
     1             'D','A','B','S',' ',' ',' ',' ',' ',' ',
     2             'I','A','B','S',' ',' ',' ',' ',' ',' ',
     3             'F','L','O','A','T',5*' ','I','F','I','X',6*' ',
     5             'A','I','N','T',6*' ','I','N','T',7*' ',
     7             'I','D','I','N','T',5*' ','E','X','P',7*' ',
     9             'D','E','X','P',6*' ','A','L','O','G','1','0',4*' ',
     2             'D','L','O','G','1','0',4*' ','A','L','O','G',6*' ',
     4             'D','L','O','G',6*' ','S','Q','R','T',6*' ',
     6             'D','S','Q','R','T',5*' ','S','I','N',7*' ',
     8             'D','S','I','N',6*' ','C','O','S',7*' ',
     1             'D','C','O','S',6*' ','T','A','N','H',6*' ',
     2             'D','T','A','N','H',5*' ','A','T','A','N',6*' ',
     3             'D','A','T','A','N',5*' ',
     1             'A','S','I','N',6*' ','D','A','S','I','N',5*' ',
     2             'A','C','O','S',6*' ','D','A','C','O','S',5*' ',
     3             'T','A','N',' ',6*' ','D','T','A','N',106*' '/
	DATA EXCODE/112/
       DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
     1 6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
     2       4,44,5,44,4,45,5,45,4,46,5,46,3,47,4,47,20*0/
C
10	CONTINUE
	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 50
C
C  NO MORE ELEMENTS
	LASTOP=0
	RETCD=3
	RETURN
C
C
C  INITIALIZE VARIABLES
50	CONTINUE
	B10=0
	B16=0
	RETTYP=0
	RETPT=0
	REAL=0.D0
	RETCD=1
	DEFBAS=BASED
C	RVLF=0.0D0
C COMMENT OUT DO LOOP OVER 20 BYTES FOR SPEED.
C (INSTEAD JUST ZERO 8 BYTES WE WILL LIKELY USE)
	DO 60 I=1,8
C	DO 60 I=1,20
60	RETVAL(I)=0
C
70	CHAR1=LINE(IPT)
	NONBLK=IPT
C
C
C  SEE IF ALPHABETIC OR %
C SHORTCUT IF IT'S A CELL NAME .. GO JUST EVALUATE IT.
C ALSO WORKS FOR ENCODED FUNCT NAMES.
	IF(ICHAR(CHAR1).GE.255)GOTO 12000
C SEPARATE OUT FUNCTION CALLS FOR FASTER EXECUTION...SKIP TRYING FUNCT. NAME
C FIRST AS VARIABLE NAME (WHICH CAN TAKE LONG TIME TO CONVERT BEFORE WE DISCOVER
C IT ISN'T NEEDED...)
C
	IF(ICHAR(CHAR1).GE.230)GOTO 13201
C ADD COUPLE MORE SHORTCUTS... DON'T JUST LOOP TO SEE IF WE HAVE
C AN ALPHA CHARACTER...
	IF(CHAR1.NE.ALPHA(27))GOTO 78
	I=27
	GOTO 10000
78	CONTINUE
	IF(CHAR1.LT.'A'.OR.CHAR1.GT.'Z')GOTO 79
C TRY TO AVOID LOTS OF EXTRA FUNCTION CALLS...
C COMPARE CHARS AS CHARACTER VALUES... SHOULD STILL BE OK.
CCC	IF(ICHAR(CHAR1).LT.ICHAR(ALPHA(1))
CCC     1  .OR.ICHAR(CHAR1).GT.ICHAR(ALPHA(26)))GOTO 79
C USE FACT THAT ASCII CHARACTER CODES ARE IN A CONTINUOUS RANGE
CCC	I=ICHAR(CHAR1)-ICHAR(ALPHA(1))
	I=ICHAR(CHAR1)-65
C 65 IS ASCII VALUE FOR 'A' CHARACTER.
C (HARDCODE FOR SPEED...)
	GOTO 10000
79	CONTINUE
C DELETE 3 LINES FOLLOWING:
C	DO 80 I=1,27
C	IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
C80	CONTINUE
C
C
C  NOT ALPHA SO SEE IF AN OPERATOR
	DO 100 I=1,9
	IF (CHAR1.EQ.OPER(I)) GOTO 20000
100	CONTINUE
C
C
C SEE IF AN OPERAND
C *** EVIDENTLY SHORT LOOP RUNS AS FAST AS A COUPLE DECISIONS AND SOME
C MATH; LEAVE IN.
140	DO 150 I=1,16
	IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
150	CONTINUE
C
C
C
	IF (CHAR1.EQ.DOT) GOTO 40000
C
C
C
	IF (CHAR1.EQ.ARROW) GOTO 300
C
C
C
	IF (CHAR1.EQ.QUOTE) GOTO 200
C
C
C  ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
C
C
C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
190	CALL ERRMSG (20)
	GOTO 99000
C
C
C
C
C **************************************
C ****** ASCII CONSTANT SPECIFIED ******
C **************************************
200	CONTINUE
	NONBLK=NONBLK+1
	RETVAL(1)=ICHAR(LINE(NONBLK))
	RETTYP=1
	GOTO 35100
C
C
C
C
C **************************************
C ****** IMMEDIATE BASE SPECIFIED ******
C **************************************
300	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 320
C
C
C *** ERROR *** ILLEGAL BASE SPECIFICATION
310	CALL ERRMSG(19)
	GOTO 99000
C
C
C  IMMEDIATE BASE SPECIFICATION
320	CHAR1=LINE(IPT)
	NONBLK=IPT
	IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
	IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
C
C
C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 310
	CHAR1=LINE(IPT)
	NONBLK=IPT
	IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
	IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
C
C
C IMMEDIATE BASE IS 16
	DEFBAS=16
	GOTO 370
C
C
C IMMEDIATE BASE IS 8
360	DEFBAS=8
	GOTO 370
C
C
C IMMEDIATE BASE IS 10
365	DEFBAS=10
C
C
C
370	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 310
	CHAR1=LINE(IPT)
	NONBLK=IPT
C
C
C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
	GOTO 140
C
C
C
C
C ****************************************************
C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
C ****************************************************
10000	CONTINUE
	IALPHA=I
	IHOLD=NONBLK
C
C
C SCAN EACH OF THE FUNCTION NAMES.
	DO 10060 I=1,FCNT
C
C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
	K=FUNVAL(1,I)
	IPT2=IHOLD
	NONBLK=IHOLD
	IF (K.EQ.0) GOTO 10060
C
C
C SCAN EACH LETTER OF THE FUNCTION'S NAME
	DO 10050 J=1,K
	IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
	IF (J.EQ.K) GOTO 10100
	CALL GETNNB (IPT2,RETCD2)
	IF (RETCD2.EQ.2) GOTO 10060
	NONBLK=IPT2
10050	CONTINUE
	STOP 10050
C
10060	CONTINUE
10070	NONBLK=IHOLD
	GOTO 12000
C
C
C  FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
10100	CONTINUE
C
C
C
C
C **********************************
C ****** UNARY FUNCTION FOUND ******
C **********************************
	RETTYP=ICHAR(CHAR(FUNVAL(2,I)))
	LASTOP=RETTYP
	RETCD=2
	GOTO 99099
C
C
C
C
C
C ********************************
C ****** VARIABLE SPECIFIED ******
C ********************************
12000	CONTINUE
C
C
C  IALPHA HOLDS INDEX INTO ALPHA OF NAME
C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
C	CALL GETNNB (IPT,RETCD2)
C	IF (RETCD2.EQ.2) GOTO 12060
CC
CC
CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
C	DO 12050 I=1,27
C	IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
C12050	CONTINUE
C *****&&&&& ...ENDING HERE
C ADD BELOW...
	LLB=IPT
	LRB=LEND
	CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
C	IF(IVALID.EQ.0)GOTO 12200
C	IPT=LSTCHR
	IF(IVALID.NE.0.AND.ID2.LE.1.AND.ID1.GT.60)GOTO 13201
	IF(IVALID.NE.0)GOTO 12201
C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
C
C COME HERE DIRECT FOR FUNCTIONS ENCODED...
13201	CONTINUE
	I=IPT+9
	CALL FNAME(LINE(IPT),I,INDEXF)
	IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 12202
C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
	LLAST=LEND-IPT+1
	I=INDX(LINE(IPT),ICHAR(']'))
	IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
	LRB=I
	LLB=INDX(LINE(IPT),ICHAR('['))
	IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
	CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
	XAC=ACX
	TYPE(1,1)=2
	CALL TYPSET(1,27,TYPE(1,1))
C	TYPE(27,1)=2
	ID1=27
	ID2=1
	LSTCHR=LRB+IPT
C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
C RETURN ITS VALUE.
	GOTO 12201
C IF NOT VALID FUNCTION REPORT AN ERROR.
12202	GOTO 12200
12201	IPT=LSTCHR
	IF(LSTCHR.LT.LEND)IPT=IPT-1
	NONBLK=IPT
C RESET NONBLK ALST SO WE RESET GETNNB TOO...
C WAS IPT=LSTCHR+1
C IPT POINTS AFTER VARIABLE NAME...
C ENSURE NON ALPHA AFTER VARIABLE NAME
	CALL GETNNB(IPT,RETCD2)
	IF(RETCD2.EQ.2) GOTO 12060
C
C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
C OF RETVAL.
	IF (LINE(IPT).EQ.EQ) GOTO 12100
C
C
C ************************************************
C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
C ************************************************
12060	CALL TYPGET(ID1,ID2,RETTYP)
C12060	RETTYP=TYPE(ID1,ID2)
C *****&&&&&
C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
	IF (RETTYP.EQ.5)RETTYP=4
	IF (RETTYP.EQ.6)RETTYP=8
	IF (RETTYP.EQ.7)RETTYP=3
12061	CONTINUE
	IF(RETTYP.LE.0)GO TO 12080
	K=VLEN(RETTYP)
	DO 12070 I=1,K
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12068
C TRY AND CALL XVBLGT HERE TO GET VALUE ALL AT ONCE
C TO AVOID MULTIPLE ARBITRATION...
	IF(I.EQ.K)CALL XVBLGT(ID1,ID2,RETVAL)
C	CALL VBLGET(I,ID1,ID2,RETVAL(I))
C	RETVAL(I)=VBLS(I,ID1,ID2)
	GOTO 12070
12068	RETVAL(I)=AVBLS(I,ID1)
12070	CONTINUE
C
12080	LASTOP=RETTYP
	GOTO 99099
C
C
C
C *******************************************************
C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
C *******************************************************
12100	CONTINUE
C	RETVAL(1)=IALPHA
C	RETTYP=TYPE(IALPHA)
	CALL TYPGET(ID1,ID2,TYPE(1,1))
	CALL RVBOO(RETVAL,ID1,ID2)
C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
C AS 2 INTEGERS.
	RETTYP=TYPE(1,1)
	GOTO 12080
C
C
C
C *** ERROR *** UNIDENTIFIED FUNCTION
12200	CALL ERRMSG(18)
	GOTO 99000
C
C
C
C
C
C **********************
C ****** OPERATOR ******
C **********************
C
C  I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
20000	CONTINUE
	RETCD=2
	IF(I.NE.4)GO TO 20050
C
C
C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
	CALL GETNNB (IPT,RETCD2)
	IF(RETCD2.NE.1)GO TO 99000
	IF (LINE(IPT).NE.STAR) GOTO 20050
C
C
C '**' SPECIFIED (EXPONENTIATION)
	RETTYP=EXCODE
	NONBLK=IPT
	GO TO 12080
C
C
C
C  SET DEFAULT RETTYP FOR OPERATORS
20050	RETTYP=109+I
C
C
C  CHECK OUT POSSIBLE UNARY OPERATOR "-"
	IF (RETTYP.NE.111) GOTO 20080
C
C
C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
C IS UNARY.
	IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
     ;      LASTOP.EQ.200) GOTO 20090
C
C
C  BINARY SUBTRACTION OPERATOR
	RETTYP=116
	GOTO 12080
C
C
C
C SEE IF A '+' SIGN
20080	IF(RETTYP.NE.115)GO TO 20085
C
C
C DETERMINE IF IT IS A UNARY PLUS
	IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
C
C
C SEE IF LAST OPERATOR WAS ')'
	IF(LASTOP.EQ.117)GO TO 20085
C
C
C UNARY '+' FOUND.
	RETCD=1
	GO TO 10
C
C
C
C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
C IF RETTYP IS FOR =, SET TO PROPER CODE
20085	IF(RETTYP.EQ.110)GO TO 20090
	IF(RETTYP.EQ.118)RETTYP=200
	GO TO 12080
C
C
C UNARY -
20090	CONTINUE
	GOTO 99097
C
C
C
C
C
C
C *************************
C ****** NON-DECIMAL ******
C *************************
C
30000	RETPT=RETPT+1
	IF (RETPT.LE.19) GOTO 30020
C
C
C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 19 DIGITS
C (ACTUALLY, NO LONGER PRESENT...)
	CALL ERRMSG(22)
	GOTO 99000
C
C
C  I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
C  SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
30020	IF (I.NE.16) GOTO 30030
	I=0
	GOTO 30050
30030	IF (I.EQ.8.OR.I.EQ.9) B10=1
	IF(I.GT.9) B16=1
30050	RETVAL(RETPT)=CHAR(I)
C
C
C GET NEXT CHARACTER
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.NE.1) GOTO 30100
	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 30070 I=1,16
	IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
30070	CONTINUE
	IF (CHAR1.EQ.DOT) GOTO 40000
	NONBLK=NONBLK-1
30100	CONTINUE
C
	IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
	IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
C
c add code here to check for non -calc mode and goto 40000 if so
c if defbas.ne.8 and if we're working on a floating number
C
C *****************************
C ****** BASE 8 CONSTANT ******
C *****************************
	BASE=8
C
C
C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
	IF (RETPT.GT.10) GOTO 30170
	RETTYP=8
C
C
C  CONVERT TO OCTAL, HEX OR INTEGER
30110	INT=0
30130	DO 30132 L=1,7
	IF (ICHAR(RETVAL(L)).NE.0) GOTO 30140
30132	CONTINUE
30140	DO 30150 I=L,RETPT
	INT=INT*BASE+ICHAR(RETVAL(I))
	RETVAL(I)=0
30150	CONTINUE
	RETVAL(20)=0
30155	DO 30160 I=1,4
30160	RETVAL(I)=FOUR(I)
	GOTO 35100
C
C
C ************************************************
C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
C ************************************************
30170	RETTYP=6
30180	CALL FLIP (RETVAL,8,RETPT)
c was 20 above, not 8 but we shortened stack arrays so shorten this
	GOTO 35100
C
C
C
C *********************
C ****** BASE 16 ******
C *********************
30200	BASE=16
C
C
C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
	IF (RETPT.GT.7) GOTO 30270
C
C
C
C  HEXADECIMAL
	RETTYP=3
	GOTO 30110
C
C
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 16 ******
C ****************************************
30270	RETTYP=7
	GOTO 30180
C
C
C *********************
C ****** BASE 10 ******
C *********************
30300	BASE=10
C
C
C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
	IF (RETPT.GT.9) GOTO 30370
C
C
C  INTEGER
	RETTYP=4
	GOTO 30110
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 10 ******
C ****************************************
30370	RETTYP=5
	GOTO 30180
C
C
C
C
C
C SET LASTOP AND EXIT
35100	LASTOP=RETTYP
	GOTO 99099
C
C
C *****************************
C ****** REAL OR DECIMAL ******
C *****************************
40000	IF (B16.NE.1) GOTO 40020
C
C
C *** ERROR ***  '.' MAY ONLY BE USED WITH BASE 10
	CALL ERRMSG(21)
	GOTO 99000
C
C
C
40020	IF (RETPT.EQ.0) GOTO 40200
C
C
C IGNORE LEADING ZEROES
	DO 40022 L=1,19
	IF (ICHAR(RETVAL(L)).NE.0) GOTO 40030
40022	CONTINUE
C
C IF ALL ZEROES THE LAST ONE COUNTS!
	L=19
C
C
C CONVERT TO A REAL*8 NUMBER
40030	CONTINUE
	REAL=0.D0
	DO 40060 I=L,RETPT
	REAL=REAL*10.D0+ICHAR(RETVAL(I))
	RETVAL(I)=0
40060	CONTINUE
C
C
C  PICK UP FRACTIONAL PART OF REAL (DECIMAL)
40200	CONTINUE
	RB=1.0D0
	RETTYP=2
40205	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 40300
C
C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
	GOTO 40537
C
C
C
40300	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 40320 I=1,10
	IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
40320	CONTINUE
	GOTO 40350
40330	IF (I.EQ.10) I=0
	RB=0.1D0*RB
	REAL=REAL+DFLOAT(I)*RB
	GOTO 40205
C
C
C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
40350	IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
	NONBLK=NONBLK-1
	GO TO 40537
C
C
C *********************************************
C ****** E AND D EXPONENT SPECIFICATIONS ******
C *********************************************
40360	CONTINUE
	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 40370
C
C
C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
40365	CALL ERRMSG (24)
	GOTO 99000
C
C
40370	CHAR1=LINE(IPT)
	IF (CHAR1.EQ.MINUS) GOTO 40380
	RB=10.D0
	IF (CHAR1.NE.PLUS) GOTO 40400
	GOTO 40390
40380	RB=0.1D0
C
C
C
40390	NONBLK=IPT
	CALL GETNNB (IPT,RETCD2)
40400	IF (RETCD2.GE.2) GOTO 40365
	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 40450 I=1,10
	IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
40450	CONTINUE
	GOTO 40365
40480	IF (I.EQ.10) I=0
C
C
C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
	I1=I
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.GE.2) GOTO 40550
	CHAR1=LINE(IPT)
	NONBLK=IPT
	DO 40500 I=1,10
	IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
40500	CONTINUE
	NONBLK=NONBLK-1
	GOTO 40550
C
C
C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
40520	IF (I.EQ.10) I=0
	I2=I
C
C
40530	RETTYP=9
	REAL=REAL*RB**(I1*10+I2)
C
C
C
C ***************************************************
C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
C ***************************************************
40537	DO 40540 I=1,8
40540	RETVAL(I)=EIGHT(I)
	GOTO 35100
C
C
C
40550	I2=I1
	I1=0
	GOTO 40530
C
C
C
C ********************************
C ******* ERROR PROCESSING *******
C ********************************
99000	CONTINUE
	IV=LEND-NONBLK+1
	CALL VWRT(LINE(NONBLK),IV)
C	WRITE (0,99010) (LINE(I),I=NONBLK,LEND)
C99010	FORMAT (1X,80(A1,\))
	RETCD=4
99097	LASTOP=0
99099	RETURN
	END
c -h- pget.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE PGET(CMDLIN,ICODE,IRTN)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	COMMON/NMSH/NMSH
	REAL*8 XVBLS(1,1)
	INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IOLVL
	INTEGER*4 JVBLS(2,1,1)
CCC	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	DIMENSION FORM(128),FVLD(1,1)
	CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2

C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
	CHARACTER*1 LETA
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	InTeGer*4 LLCMD,LLDSP
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XAC,ZAC
	EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
	REAL*8 XXAC,XYAC
	EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	CHARACTER*1 ARGSTR(52,4)
CCC	COMMON/ARGSTR/ARGSTR
C	EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	INTEGER*4 IIRO,IICO,INUMEM
C NEED SOME BIG VARIABLES FOR SAVING THE MAPPINGS
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	COMMON/KLVL/KLVL
	CHARACTER*1 DEFVB(12)
	COMMON/DEFVBX/DEFVB
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	CHARACTER*76 CFORM
	EQUIVALENCE(CFORM(1:1),FORM(1))
	COMMON /FVLDC/FVLD
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	InTeGer*4 ICREF,IRREF
CCC	COMMON/MIRROR/ICREF,IRREF
C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
C
C PUT NUMBERS OUT TO FILE
C USES RELATIVE FORMS TO CURRENT POS.
C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
C ONLY WRITES PHYSICALLY PRESENT DATA.
C P/D RRR,CCC,FORMULA,VALID,FORMAT
C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
	ICODE=1
	CLOSE(4)
7954	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
C ASK FOR FILE NAME
	CALL VWRT('Enter Filename>',15)
	III=IOLVL
C	IF(III.EQ.5)III=0
	READ(III,7953,END=510,ERR=510)FORM2
c7952	FORMAT(' Enter filename>\')
7953	FORMAT(128A1)
	DO 6940 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
	FORM2(ILN)=0
6940	CONTINUE
6941	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=0
	CALL WASSIG(4,FORM2)
C NOW ENCODE COL WIDTHS AND ICREF/IRREF
C SO SAVE/RESTORE OF EXTENDED SHEETS DOESN'T GET
C MESSED UP.
	WRITE(CFORM(1:76),8850,ERR=8851)ICREF,IRREF,(CWIDS(III),
     1  III=1,20),DRWV,DCLV
8850	FORMAT(24I3)
	DO 8855 III=1,80
	II=ICHAR(NMSH(III))
	IF(II.LT.32)II=32
8855	NMSH(III)=CHAR(II)
8851	CONTINUE
	WRITE(4,6951)NMSH,(FORM(II),II=1,76)
6951	FORMAT(80A1,76A1)
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter max. displ down to save or 0 for all>',43)
	III=IOLVL
C	IF(III.EQ.5)III=0
	READ(III,7978,END=510,ERR=510)LDXM
6950	FORMAT(80A1)
7978	FORMAT(I7)
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter max. displcmt right to save or 0 for all>',47)
	III=IOLVL
C	IF(III.EQ.5)III=0
	READ(III,7978,END=510,ERR=510)MDXM
	IF(MDXM.LE.0)MDXM=12000
	IF(LDXM.LE.0)LDXM=12000
C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID
C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN
C INTEGER THOUGH.
	IF(CMDLIN(2).NE.'P'.and.CMDLIN(2).GT.' ')GOTO 7950
C TREAT "P" BY ITSELF AS A SAVE PP TYPE COMMAND (PUT PHYS)
	DO 7951 ICO=PCOL,301
	DO 7951 IRO=PROW,60
C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY.
C	IRX=(ICO-1)*60+IRO
	CALL REFLEC(ICO,IRO,IRX)
	IDRO=IRO-PROW+1
	IDCL=ICO-PCOL+1
	IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951
C FORM DISPLACEMENT LOCATORS
	CALL FVLDGT(IRO,ICO,FVLD(1,1))
	IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7951
	CALL WRKFIL(IRX,FORM,0)
	CALL CE2A(FORM,FORM2)
	IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
	IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	CALL TYPGET(IRO,ICO,TYPE(1,1))
	IF(CMDLIN(3).NE.'N')GOTO 5402
	IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5402
C ALWAYS WRITE TEXT OUT EVEN IF SAVING NUMERICALLY
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
C INTERNAL PROC TO PRINT NUMERIC VALUES AT 6400
	LETR='P'
	ASSIGN 5405 TO INUMEM
C	GOTO 6400
6400	CONTINUE
C ASSUME LETR IS SET TO GOOD PREFIX LETTER ASCII VALUE
	CALL XVBLGT(IRO,ICO,XVBLS(1,1))
	IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL,
     1  JVBLS(1,1,1)
5403	FORMAT(1A1,I5,',',I5,',',I15)
	IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL,
     1  XVBLS(1,1)
5404	FORMAT(1A1,I5,',',I5,',',D30.19)
	GOTO INUMEM,(5405,6406)
5402	CONTINUE
C FIND END OF TEXT IN ARRAY
	DO 4330 IV=2,110
	IVVV=113-IV
	IF(ICHAR(FORM2(IVVV)).GT.32)GOTO 4331
4330	CONTINUE
4331	CONTINUE
C SAVE ON PPX IN EFFICIENT FORM.
C DON'T WRITE OUT TRAILING NULLS.
C ENSURE FORMAT HAS NO NULLS IN IT.
	DO 358 IV=120,128
358	IF(ICHAR(FORM2(IV)).LT.32)FORM2(IV)=Char(32)
	IF(CMDLIN(3).EQ.'F')GOTO 6404
C PPF WILL SAVE FORMULAS ONLY
C PPA WILL SAVE FORMULAS AND VALUES (AS WILL PPc WHERE c IS
C ANY CHARACTER EXCEPT N.
	LETR='p'
C FLAG NUMERIC SAVE VIA LOWERCASE P HERE
	ASSIGN 6406 TO INUMEM
C GO WRITE FIRST LINE NUMERICALLY
	GOTO 6400
6406	CONTINUE
C NOW HAVE NUMERIC LINE WRITTEN. WRITE THE SECOND LINE OF THE
C GROUP TO, SO AS NOT TO CONFUSE GRAPHICS PROGRAMS AND THE
C LIKE.
	III=JCHAR(FORM2(119))
	WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
6404	CONTINUE
C NOW WRITE OUT FORMULA RECORD.
	WRITE(4,7955)IDRO,IDCL,(FORM2(IV),IV=1,IVVV)
5405	CONTINUE
C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII.
7955	FORMAT('P',I5,',',I5,',',128A1)
C NOTE LONG RECORDS.
	III=JCHAR(FORM2(119))
	WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7956	FORMAT(I3,',',9A1,',',I5)
7951	CONTINUE
2751	CONTINUE
C
C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO
C ONLY SAVE MAPPINGS IF 4TH COMMAND CHARACTER IS "M".
C ... THEY TAKE A LOT OF ROOM.
	IF (CMDLIN(4).NE.'M') GOTO 6541
	DO 6540 IRO=DROW,20
	DO 6540 ICO=DCOL,75
	IIRO=64000
	IICO=IIRO
	IIRO=IIRO+IRO
	IICO=IICO+ICO
C NOTE WE MAKE THESE NUMBERS LARGE SO GRAPHING PROGRAMS WON'T TRY
C TO READ THEM.
6955	FORMAT('M',I5,',',I5,',',2I7)
	WRITE(4,6955,ERR=6541)IIRO,IICO,NRDSP(IRO,ICO),
     1  NCDSP(IRO,ICO)
C WRITE A SPECIAL RECORD, FLAGGED BY 'M', TO SAVE A MAPPING CELL
C NEED A 2ND RECORD TOO; JUST SEND LAST ONE AGAIN.
	WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
6540	CONTINUE
6541	CONTINUE
	CLOSE(4)
	GOTO 9990
7950	IF(CMDLIN(2).NE.'D')GOTO 9990
	DO 7957 ICO=DCOL,75
	DO 7957 IRO=DROW,20
	IDRO=IRO-DROW+1
	IDCL=ICO-DCOL+1
	IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957
	NR=NRDSP(IRO,ICO)
	NC=NCDSP(IRO,ICO)
C	IRX=(NC-1)*60+NR
	CALL REFLEC(NC,NR,IRX)
	CALL FVLDGT(NR,NC,FVLD(1,1))
	IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7957
	CALL WRKFIL(IRX,FORM,0)
	CALL CE2A(FORM,FORM2)
	IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
	IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	IF(CMDLIN(3).NE.'N')GOTO 5412
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
	IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5412
C WRITE LABELS EVEN IF NUMERIC SAVE
	CALL TYPGET(NR,NC,TYPE(1,1))
	CALL XVBLGT(NR,NC,XVBLS(1,1))
	IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1)
5413	FORMAT('P',I5,',',I5,',',I15)
	IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1)
5414	FORMAT('P',I5,',',I5,',',D30.19)
	GOTO 5415
5412	CONTINUE
	WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110)
5415	CONTINUE
7958	FORMAT('D',I5,',',I5,',',128A1)
	DO 359 IV=120,128
359	IF(FORM2(IV).LT.' ')FORM2(IV)=Char(32)
	III=JCHAR(FORM2(119))
	WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7957	CONTINUE
C ALLOW SAVE AS NEEDED OF MAPPING
	GOTO 2751
C	CLOSE(4)
9990	RETURN
510	CONTINUE
	IRTN=1
	CLOSE(IOLVL)
	CLOSE(11)
	OPEN(11,FILE='CON:0/0/100/100/Analy Command')
	RETURN
	END
c -h- pgget.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE PGGET(CMDLIN,ICODE,IRTN)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	COMMON/NMSH/NMSH
	REAL*8 XVBLS(1,1)
	INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IOLVL
	INTEGER*4 JVBLS(2,1,1)
	REAL*8 R8WK
CCC	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	DIMENSION FORM(128),FVLD(1,1)
	INTEGER*4 IRRW,ICCL
C USE BIG NUMBERS SO WE CAN SUBTRACT 64000 AND STILL NOT GET WRAPAROUND.
C (FOR SAVE/RESTORE OF MAP)
	CHARACTER*76 CFORM
	CHARACTER*35 CFORM2
	EQUIVALENCE(CFORM2(1:1),FORM2(1))
	EQUIVALENCE(CFORM(1:1),FORM(1))
	InTeGer*4 NDUM(24)
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	COMMON/MIRROR/ICREF,IRREF
	CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	InTeGer*4 LLCMD,LLDSP
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	EXTERNAL INDX
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
	REAL*8 XAC,ZAC
	EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
	REAL*8 XXAC,XYAC
	EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	CHARACTER*1 ARGSTR(52,4)
CCC	COMMON/ARGSTR/ARGSTR
C	EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
	EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
	EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC	COMMON/KLVL/KLVL
	CHARACTER*1 DEFVB(12)
	COMMON/DEFVBX/DEFVB
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
	InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
	REAL*8 DVS(20,75)
	INTEGER*4 LDVS(2,20,75)
	EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
	COMMON /FVLDC/FVLD
CCC	InTeGer*4 NCEL,NXINI
CCC	COMMON/NCEL/NCEL,NXINI
C	CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
	COMMON/DSPCMN/DVS,CWIDS
C
c7952	FORMAT(' Enter filename>\')
7953	FORMAT(128A1)
6950	FORMAT(80A1)
7978	FORMAT(I7)
7956	FORMAT(I3,1X,9A1,1X,I5)
	CLOSE(4)
7960	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
C GET FILE NAME
	call Vwrt('Enter Filename>',15)
	III=IOLVL
C	IF(III.EQ.5)III=0
	READ(III,7953,END=510,ERR=510)FORM2
	DO 6940 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
	FORM2(ILN)=Char(0)
6940	CONTINUE
6941	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(127,ILN)
	FORM2(ILN+1)=Char(0)
C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS...
	NXINI=1
	LDXM=INDX(FORM2,ICHAR('/'))
C IF FILE IS FILENAME/M WE WON'T DO IT FAST...
	IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400
	FORM2(LDXM)=Char(0)
C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN
	NXINI=0
8400	CONTINUE
	CALL RASSIG(4,FORM2)
	READ(4,6951,END=7964,ERR=7964)NMSH,FORM
6951	FORMAT(80A1,76A1,56A1)
6952	FORMAT(24I3)
C TRY TO DECODE ICREF,IRREF, CWIDS, AND DRWV,DCLV
	READ(CFORM(1:76),6952,ERR=6953)NDUM
C IF HERE, THE READ WAS OK (APPARENTLY)
C FILL IN DEFAULTS IF NOTHING BUT ZEROES REALLY WAS SEEN
C (OR JUST ALL SPACES)
	ICREF=NDUM(1)
	IF(ICREF.LE.0.OR.ICREF.GT.60)ICREF=10
	IRREF=NDUM(2)
	IF(IRREF.LE.0.OR.IRREF.GT.300)IRREF=50
C SET UP CWIDS BUT DEFAULT TO 10 IF NO REAL INFO THERE
	DO 6954 III=1,20
	IIVV=NDUM(III+2)
	IF(IIVV.LT.1.OR.IIVV.GT.100)IIVV=10
	CWIDS(III)=IIVV
6954	CONTINUE
C RESTORE NUMBER ROWS AND COLS BEING DISPLAYED
C NOTE WE DO NOT RESTORE THE COMPLETE DISPLAY
C MAPPING; JUST THE WIDTHS AND NUMBERS OF DISPLAY
C COLUMNS, AND WE RESTORE THE EXTENDED MAP SO THAT
C SAVED SHEETS WILL NORMALLY GET BACK THE SAME EXTENDED
C ADDRESSING THAT HAD BEEN SET UP.
	DRWV=NDUM(23)
	IF(DRWV.LT.1.OR.DRWV.GT.20)DRWV=7
	DCLV=NDUM(24)
	IF(DCLV.LT.1.OR.DCLV.GT.75)DCLV=20
6953	CONTINUE
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter max. displc. down to restore or 0 for all>',48)
	III=IOLVL
C	IF(III.EQ.5)III=0
	READ(III,7978,END=510,ERR=510)MDXM
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter max. displc. right to restore or 0 for all>',
     1  49)
	READ(III,7978,END=510,ERR=510)LDXM
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter min. displ. down (1 or more)>',35)
	READ(III,7978,END=510,ERR=510)MMDXM
	CALL UVT100(1,LLCMD,1)
	CALL UVT100(12,2,0)
	CALL VWRT('Enter min displ. right (1 or more)>',35)
	READ(III,7978,END=510,ERR=510)LLDXM
	IF(MDXM.LE.0)MDXM=12000
	LLDXM=MAX0(1,LLDXM)
	MMDXM=MAX0(1,MMDXM)
	IF(LDXM.LE.0)LDXM=12000
	IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1
C ENTER RECALC MANUAL MODE IF ADDING NUMBERS OR SUBT.
C FROM SAVED SHEET
C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER.
7961	CONTINUE
	READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV),
     1  IV=1,110)
7962	FORMAT(A1,I5,1X,I5,1X,128A1)
	DO 4497 IV=1,110
	IVV=111-IV
	IF(FORM2(IVV).GT.' ')GOTO 4496
	FORM2(IVV)=Char(0)
4497	CONTINUE
4496	CONTINUE
C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE
C ZEROED ON READIN.
	READ(4,7956,END=7964,ERR=7964)III,(FORM2(IV),IV=120,128),
     1  KKTYP
	FORM2(119)=Char(III)
	IF(LET1.EQ.'M')GOTO 6500
C M CODE MEANS WE'RE READING THE DISPLAY-TO-PHYSICAL MAP.
C GO HANDLE IT SPECIALLY, THEN RETURN. FLAGS RECORDS BY
C ADDING 64000 TO ROW AND COL NUMBERS TO AVOID GETTING
C GRAPHICS PROGRAMS MESSED UP.
C  NOTE THAT SAVING THE MAP WAS OPTIONAL AND IS NOT THE
C DO-NOTHING DEFAULT.
	IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
	IF(JCHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
	IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990
	IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961
	IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961
C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES
C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR).
C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY.
	NR=IRRW+PROW-LLDXM
	NC=ICCL+PCOL-MMDXM
	IF(CMDLIN(2).NE.'D'.AND.LET1.NE.68)GOTO 7963
	IF(CMDLIN(2).EQ.'P')GOTO 7963
C GET DISPLAY VERSION...
	LRR=IRRW+DROW-LLDXM
	LCC=ICCL+DCOL-MMDXM
	LRR=MAX0(1,LRR)
	LCC=MAX0(1,LCC)
	IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961
	NR=NRDSP(LRR,LCC)
	NC=NCDSP(LRR,LCC)
7963	CONTINUE
C LET1='p'WILL COME HERE TOO. HANDLE IT SINCE IT'S NUMERIC STUFF.
C	IRX=(NC-1)*60+NR
	CALL REFLEC(NC,NR,IRX)
	IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961
	FORM2(118)=CHAR(15)
	DO 7113 IVV=1,128
7113	FORM(IVV)=FORM2(IVV)
	INRW=PROW
	INCL=PCOL
	JOUTR=1
	JOUTC=2
C A1 = OUT LOCATION FOR INPUT CELL NAMES
	JRTR=1
	JRTC=1
	IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC,
     1  INRW,INCL,JRTR,JRTC)
C ALLOW RELOCATION ON LOADING SAVED SHEET IF DESIRED.
	CALL FVLDST(NR,NC,FORM2(119))
C	FVLD(NR,NC)=FORM2(119)
	CALL TYPSET(NR,NC,KKTYP)
C	TYPE(NR,NC)=KKTYP
	CALL CA2E(FORM2,FORM)
	IF(LET1.NE.'p')CALL WRKFIL(IRX,FORM,1)
C	WRITE(7'IRX)FORM2
	IF(LET1.NE.'p')GOTO 7961
C HAVE LOWERCASE 'p' NOW AS NUMERIC SAVE FLAG FOR THIS RECORD.
	READ(CFORM2(1:35),6408,ERR=7961)XVBLS(1,1)
6408	FORMAT(BN,D30.19)
	CALL XVBLGT(NR,NC,R8WK)
	IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK
	IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1)
C IMPLEMENT ADDING AND SUBTRACTING SAVED SHEETS FROM CURRENT.
C GOES TO RECALC MANUAL MODE SINCE RECALC WOULD MESS UP
C VALUES; FORMULAS GET UPDATED FROM LAST-READ SHEET NORMALLY.
	CALL XVBLST(NR,NC,XVBLS(1,1))
	GOTO 7961
6500	CONTINUE
C HERE READ MAPPINGS
	IRRW=IRRW-64000
	ICCL=ICCL-64000
C RESTORE OFFSETS TO NORMAL RANGE
	READ(CFORM2(1:35),6501,ERR=7961)II,III
6501	FORMAT(2I7)
	NRDSP(IRRW,ICCL)=II
	NCDSP(IRRW,ICCL)=III
C GO BACK FOR MORE. INEFFICIENT STORAGE OF MAP BUT IT'S COMPACT
C CODE...
	GOTO 7961
7964	CONTINUE
	CLOSE(4)
9990	NXINI=0
	RETURN
510	CONTINUE
	IRTN=1
	NXINI=0
	CLOSE(IOLVL)
	CLOSE(11)
	OPEN(5,FILE='CON:0/0/100/100/Analy Command')
	RETURN
	END
c -h- pmtx2.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	CHARACTER*1 LINE(80)
	CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)
C GET LOC OF MATRIX A (MUST BE SQUARE)
	IBGN=LSTCHR+1
	IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
	IF(LINE(LSTCHR).NE.',')GOTO 300
	CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
     1  IDYB,RETCD)
C GET LOC OF MATRIX X (RESULT).
	IBGN=LSTCHR+1
	IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
	IF(LINE(LSTCHR).NE.',')GOTO 300
	CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
     1  IDCB,RETCD)
	IBGN=LSTCHR+1
C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
C FOR ERROR...
1000	RETURN
300	CONTINUE
	RETCD=3
	RETURN
	END
c -h- postvl.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE POSTVL (RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *

C *      SUBROUTINE  POSTVL (RETCD)                *
C *                                                *
C **************************************************
C
C
C  CONVERTS POSTFIX EXPRESSIONS IN STACK 1 TO A VALUE
C
C
C	RETCD	MEANING
C
C	1	O.K.
C	2	ERROR
C
C POSTVL CALLS
C
C CALBIN    CALCULATES BINARY OPERATIONS
C CALUN     CALCULATES UNARY OPERATIONS
C ERRMSG    PRINTS OUT ERROR MESSAGES
C VAROUT    OUTPUTS THE VALUE OF A VARIABLE
C
C
C
C
C POSTVL IS CALLED BY CALC
C
C
C
C
C VARIABLE    USE
C _________ ___________________________
C
C    I,K     TEMPORARY VALUES
C
C    PT1     POINTS TO TOP ELEMENT IN STACK1
C
C    RETCD   RETURN CODE: 1=O.K., 2=ERROR
C
C    RETCD2  USED TO HOLD RETURN CODE WHEN CALLS TO
C            OTHER ROUTINES ARE MADE.
C
C    ST1PT   STACK 1 POINTER.
C
C    ST2PT   STACK 2 POINTER.
C
C    ST1TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 1
C
C    ST2TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 2
C
C    STACK1  HOLDS ORIGINAL POSTFIX EXPRESSION.
C
C    STACK2  USED TO EVALUATE EXPRESSION IN STACK1.
C
C    TYPE(27) HOLDS THE DATA TYPE FOR EACH OF THE VARIABLES.
C
C    AVBLS(100,27) HOLDS VALUES OF VARIABLES.
C    VBLS(8,60,301) HOLDS VALUE OF COMPLEXLY-NAMED VARIABLES. 1ST 27 ELEMENTS
C	ARE PLACE HOLDERS FOR AVBLS; ROUTINES THAT GENERATE DIMENSIONS ID1,ID2
C	FOR VBLS RETURN DIMENSIONS 1-27,1 FOR A-Z,%. THESE RESULT IN AVBLS
C	ARRAY BEING USED. VBLS ARRAY (MAX LENGTH 8 BYTES/VARIABLE) IS USED
C	FOR OTHER VARIABLES WHOSE NAMES ARE <ALPHA><ALPHA><NUM><NUM>
C	(WITH OPTION FOR ANY REASONABLE # OF ALPHAS AND NUMERICS BUT CLAMPED
C	AT 60,301 VALUES TO WORK CORRECTLY.)
C
C    VIEWSW   VIEW SWITCH:
C                0 = OFF
C                1 = DISPLAY COMMANDS
C                2 = DISPLAY VALUE OF EXPRESSIONS
C                3 = DISPLAY ALL
C
C
C
C	SUBROUTINE POSTVL (RETCD)
C
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 PT1
	InTeGer*4 VIEWSW,BASED
	InTeGer*4 RETCD,RETCD2,VLEN(9)
	InTeGer*4 TYPE(1,1)
	InTeGer*4 ST1TYP(40),ST2TYP(40)
	InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
	InTeGer*4 I,K
C
	CHARACTER*1 LINE(80)
	CHARACTER*1 STACK1(8,40), STACK2(8,40),AVBLS(20,27)
	CHARACTER*1 VBLS(8,1,1)
C
	COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;	       ST1LIM,ST2LIM
	COMMON /V/ TYPE,AVBLS,VBLS,VLEN
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
C
	RETCD=1
C
C
C IF THERE IS ONE ELEMENT IN STACK1 AND IT IS NOT
C A NUMBER, THE EXPRESSION IS ILLEGAL (GO TO 95).
	IF(ST1PT.EQ.2.AND.ST1TYP(1).GT.30)GO TO 95
C
C
10	IF (ST1PT.GT.2) GOTO 40
	IF (ST1PT.EQ.1) GOTO 95
C
C
C ***************************************
C ****** ONLY 1 ELEMENT ON STACK 1 ******
C ***************************************
	K=VLEN(ST1TYP(ST1PT-1))
C
C
C COPY INTO VARIABLE %
	DO 20 I=1,K
20	AVBLS(I,27)=STACK1(I,1)
	CALL TYPSET(27,1,ST1TYP(1))
C	TYPE(27,1)=ST1TYP(1)
C
C
C OUTPUT VALUE OF %
	IF (VIEWSW.GT.1) CALL VAROUT(27,1)
	RETURN
C
C
C  MORE THAN ONE ELEMENT ON STACK1
40	CONTINUE
	IF (ST1TYP(ST1PT-1).LE.30) GOTO 90
	IF (ST2PT.LE.ST2LIM) GOTO 45
C
C
C *** ERROR *** STACK 2 OVERFLOW
	CALL ERRMSG(9)
43	RETCD=2
	RETURN
C
C
C
C
C ****************************************
C ****** OPERATOR SO PUT ON STACK 2 ******
C ****************************************
45	ST2TYP(ST2PT)=ST1TYP(ST1PT-1)
	ST2PT=ST2PT+1
	ST1PT=ST1PT-1
	IF(ST1PT.EQ.1)GO TO 95
	GOTO 40
C
C
C
C
C
C *********************
C ****** OPERAND ******
C *********************
C
C FIRST BE SURE THAT THERE IS AN OPERATOR INVOLVED ON STACK 2
C (IF ONLY ONE ELEMENT IN STACK 1 YOU SHOULD NOT BE HERE).
90	IF(ST2PT.NE.1)GO TO 110
C
C
C *** ERROR *** ILLLEGAL EXPRESSION
95	CALL ERRMSG(8)
	GO TO 43
C
C
C
C
C ENTER HERE AFTER APPLYING AN OPERATOR TO A NUMBER
100	IF (ST2PT.EQ.1) GOTO 10
110	K=ST2TYP(ST2PT-1)
C
C IF A UNARY OPERATOR, GO TO 190
	IF ((K.GT.30.AND.K.LE.47).OR.K.EQ.111) GOTO 190
C
C
C IF A BINARY OPERATOR, GO TO 170
	IF (K.GE.110.AND.K.LE.117) GOTO 170
	IF(K.EQ.200)GO TO 170
C
C IF ELEMENT ON STACK2 AT ST2PT-1 IS AN OPERAND, APPLY CALBIN AGAIN
	IF(K.LE.30) GO TO 180
	STOP 110
C
C
C
C
C ***************************************************************
C ****** CALBIN CALCULATES THE BINARY VALUE OF AN OPERATOR ******
C ***************************************************************
C  UPON ENTRANCE:
C	OPERAND 1 IS IN STACK 1
C	OPERAND 2 IS IN STACK 2
C	OPERATOR IS BELOW OPERAND 2
C  UPON EXIT RESULT IS ON STACK 1
C
C	RETURN CODE	MEANING
C
C	1		O.K.
C	2		OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C	3		ERROR ENCOUNTERED
C
C
170	CONTINUE
C
C
C FIRST PUT OPERAND 2 ONTO STACK 2
	PT1=ST1PT-1
	ST2TYP(ST2PT)=ST1TYP(PT1)
	K=VLEN(ST2TYP(ST2PT))
	DO 175 I=1,K
175	STACK2(I,ST2PT)=STACK1(I,PT1)
	ST1PT=ST1PT-1
	IF(ST1PT.EQ.1)GO TO 95
	ST2PT=ST2PT+1
C
C
C IF OPERAND 1 IS AN OPERATOR, PUT IT ON STACK 2 (GO TO 45)
	IF(ST1TYP(ST1PT-1).GT.30) GO TO 45
180	CALL CALBIN (RETCD2)
	GOTO (100,1000,43), RETCD2
	STOP 180
C
C
C
C
C
C ********************************************************************
C ****** CALL CALUN TO CALCULATE THE VALUE OF A UNARY OPERATION ******
C ********************************************************************
C	OPERATOR IS IN STACK 2
C	OPERAND IS IN STACK 1
C	UPON EXIT, OPERATOR IS POPPED OFF STACK 2
C
C	RETURN CODE	MEANING
C
C	1		O.K.
C	2		OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C	3		ERROR ENCOUNTERED
C
C
190	CALL CALUN (RETCD2)
	GOTO(100,43),RETCD2
	STOP 190
C
C
1000	RETURN
	END
c -h- prtcon.for	Tue Sep  2 10:58:55 1986	
C **********************************
C *                                *
C *    INTERNAL FUNCTION PRTCON    *
C *                                *
C **********************************
C CALLED BY MOUT ONLY
C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
	FUNCTION PRTCON(L1,IBASE)
	InTeGer*4 BASE(3)
	InTeGer*4 IBASE,K
	CHARACTER*1 L1,PRTCON,DIGITS(16,3)
	COMMON /DIGV/ DIGITS
	DATA BASE /10,8,16/
	PRTCON=L1
	IF(L1.EQ.0)PRTCON=CHAR(BASE(IBASE))
	K=ICHAR(PRTCON)
	PRTCON=DIGITS(K,IBASE)
	RETURN
	END
c -h- rassig.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	InTeGer*4 IUNIT
C &&&& MS FTN 3.2
	LOGICAL LEXIST
C &&&&
	CHARACTER*20 WK
	CHARACTER*1 WK1(20)
	EQUIVALENCE(WK(1:1),WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
	DO 1 N=1,20
	WK1(N)=' '
1	CONTINUE
	DO 2 N=1,20
	II=ICHAR(NAME(N))
	IF(II.LT.32)GOTO 3
	WK1(N)=CHAR(II)
C1	CONTINUE
2	CONTINUE
3	CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C	INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
	INQUIRE(FILE=WK(1:20),EXIST=LEXIST)
	IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
	CALL UVT100(1,1,1)
	CALL SWRT('File not found. Attempting to create.',37)
	OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
	CLOSE(IUNIT)
C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
C WILL GET EOF ON START, BUT THAT'S TOO BAD...
100	CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
	OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
77	CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
	RETURN
	END
c -h- recalc.f40	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RECALC
C COPYRIGHT (C) 1983,1984,1985,1986 GLENN EVERHART
C ALL RIGHTS RESERVED
C RECALCULATE COMMAND
C RECOMPUTE ALL ELEMENTS OF SPREADSHEET WHERE VALID.
C PARAMETER 18060=60*301
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
	CHARACTER*1 FORM,FVLD,CMDLIN(132)
	INTEGER*4 VNLT
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC     1  IRCE1,IRCE2
CCCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC     1  IRCE1,IRCE2
C ***<<< KLSTO COMMON START >>>***
	InTeGer*4 DLFG
C	COMMON/DLFG/DLFG
	InTeGer*4 KDRW,KDCL
C	COMMON/DOT/KDRW,KDCL
	InTeGer*4 DTRENA
C	COMMON/DTRCMN/DTRENA
	REAL*8 EP,PV,FV
	DIMENSION EP(20)
	INTEGER*4 KIRR
C	COMMON/ERNPER/EP,PV,FV,KIRR
	InTeGer*4 LASTOP
C	COMMON/ERROR/LASTOP
	CHARACTER*1 FMTDAT(9,76)
C	COMMON/FMTBFR/FMTDAT
	CHARACTER*1 EDNAM(16)
C	COMMON/EDNAM/EDNAM
	InTeGer*4 MFID(2),MFMOD(2)
C	COMMON/FRM/MFID,MFMOD
	InTeGer*4 JMVFG,JMVOLD
C	COMMON/FUBAR/JMVFG,JMVOLD
	COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC	InTeGer*4 DLFG
CCC	COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS HAVE BEEN SEEN, ELSE 0
	DIMENSION FORM(128),FVLD(1,1)
	COMMON/FVLDC/FVLD
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=-2 OR -3 = DISPLAY FORMULA
C FVLD=3 NUMERIC, COMPUTE ONCE THEN SET FVLD TO 2
C FVLD=2 NUMERIC CONSTANT, ALREADY COMPUTED... DO NOT RECOMPUTE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	DIMENSION NRDSP(20,75),NCDSP(20,75)
	COMMON/D2R/NRDSP,NCDSP
	InTeGer*4 TYPE(1,1),VLEN(9)
	CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
CCC	InTeGer*4 RRWACT,RCLACT
CCC	COMMON/RCLACT/RRWACT,RCLACT
CCC	InTeGer*4 KDRW,KDCL
CCC	COMMON /DOT/KDRW,KDCL
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
	InTeGer*4 PRS,PCS,DRS,DCS
	PRS=PROW
	PCS=PCOL
	DRS=DROW
	DCS=DCOL
	IF(RCMODE.EQ.2)GOTO 5500
C THE FOLLOWING 2 LOOPS DEFINE ORDER OF CALCULATION.
C HERE THIS IS: OUTER LOOP ON ROWS (ACROSS), INNER LOOP ON COLUMNS (DOWN).
C NOTE THAT N2 DEFINES THE SHEET. SINCE 1 IS THE ACCUMULATORS, JUST GO THRU
C FOR THE SHEET, NOT THE AC'S.
	DO 1 N2=2,RCLACT
	N1=1
220	CONTINUE
C	DO 2 N1=1,60
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
C 
CCCC COMMENT 2 LINES OUT WHEN FAST FVLDGT IS IN TO SPEED UP MORE...
CCCC EXTRA LOGIC IN FVPEEK DOESN'T USUALLY PAY FOR ITSELF...
CCC	CALL FVPEEK(N1,N2,NN1)
CCC	N1=NN1
	CALL FVLDGT(N1,N2,FVLD(1,1))
	IIFV=JCHAR(FVLD(1,1))
	IF (IIFV.LE.0) GOTO 2
	IRRX=(N2-1)*60+N1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
	IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 2
	KDRW=N1
	KDCL=N2
	PROW=N1
	PCOL=N2
C SEE IF THIS PHYS COL HAS A DISPLAY COL. AND IF SO SET THAT UP.
C ONLY SET TO DISPLAYED LOCS HERE TO MINIMIZE SEARCH TIME.
C NEED THIS TO HANDLE D## FORMS...
	IF (DLFG.EQ.0)GOTO 95
C IF NEVER HAD A D## FORM FORGET LOOKING FOR DISPLAY LOCS.
	DO 20 M2=1,DCLV
	DO 10 M1=1,DRWV
	M1X=M1
	M2X=M2
C LOOK FOR DISPLAY COORDS EVEN IF IN HYPERSPACE
C WE FIND ONE IF INDEX FROM REFLECT IS SAME AS WHAT
C WE'RE LOOKING FOR...
	IF(NRDSP(M1,M2).EQ.N1.AND.NCDSP(M1,M2).EQ.N2)GOTO 9
10	CONTINUE
20	CONTINUE
95	CONTINUE
C HERE IF CELL NOT DISPLAYED... SEE IF NEEDS DOING IN RI, RE MODES
	IF(RCMODE.LE.0)GOTO 9
	IF(PROW.NE.IRCE1.OR.PCOL.NE.IRCE2)GOTO 2
C SKIP UNLESS ENTER CELL.
9	CONTINUE
C IF NO DISPLAY ROW, LEAVE AT LOW RIGHT...
C USE SAVED VALUES SO WE DON'T RELY ON DO LOOP INDEX AFTER LOOP END.
	DROW=M1X
	DCOL=M2X
	CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
	LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
	DO 56 N=1,109
	LLST=111-N
	IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 57
	FORM(LLST)=Char(0)
56	CONTINUE
57	CONTINUE
	FORM(LLST)=Char(0)
	FORM(111)=Char(0)
C	IF(ICHAR(FORM(118)).NE.15)GOTO 2
	CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
C	CALL FVLDGT(N1,N2,FVLD(1,1))
	IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
2	CONTINUE
	N1=N1+1
	IF(N1.LE.RRWACT)GOTO 220
1	CONTINUE
	GOTO 5600
5500	CONTINUE
C RCMODE=2 AND NOT RM MODE
C (IN RM MODE, RECALC IS NOT CALLED...)
	DO 1701 M2=1,DCLV
	DO 1702 M1=1,DRWV
C TO HANDLE DISPLAY WHEREVER IT MAY BE, FIND ID OF PHYS CELL AND
C CONVERT TO PHYS ROW, COL AGAIN REGARDLESS OF ALIAS...
C (NOTE CALC ORDER IS THEREFORE DISPLAY ORDER, NOT SHEET ORDER...)
	K=NRDSP(M1,M2)
	KK=NCDSP(M1,M2)
	CALL REFLECT(KK,K,IV1)
	NRC=IV1-1
	N1=MOD(NRC,60)+1
	N2=((NRC-N1+1)/60)+1
C COMPUTE PHYS ROW, COL FROM DISPLAY COORDINATES.
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
	CALL FVLDGT(N1,N2,FVLD(1,1))
	IIFV=JCHAR(FVLD(1,1))
	IF (IIFV.LE.0) GOTO 1702
C FORGET THIS CELL IF NOT A COMPUTABLE ONE...
	IRRX=IV1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
	IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 1702
	KDRW=N1
	KDCL=N2
	PROW=N1
	PCOL=N2
	DROW=M1
	DCOL=M2
	CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
	LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
C (ALSO GUARANTEE WE HAVE LOTS OF NULLS AT END TO TERMINATE INDEX ROUTINES)
	DO 756 N=1,109
	LLST=111-N
	IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 757
	FORM(LLST)=Char(0)
756	CONTINUE
757	CONTINUE
	FORM(LLST)=Char(0)
	FORM(111)=Char(0)
C CALL DOENTR TO DO THE ACTUAL COMPUTATION WORK...
	CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
	IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
1702	CONTINUE
1701	CONTINUE
C END OF COMPUTATION OVER DISPLAYS
C	GOTO 5600
5600	CONTINUE
	PROW=PRS
	PCOL=PCS
	DROW=DRS
	DCOL=DCOL
C FORCE FUNCTION WORKS ONCE ONLY.
	RCONE=0
	RCMODE=IABS(RCMODE)
C SET FOR TEMP. RECALC-ALL MODES TO RETURN TO NORMAL.
	IRCE1=0
	IRCE2=0
	RETURN
	END
c -h- reflect.f40	Tue Sep  2 10:58:55 1986	
	SUBROUTINE REFLEC(ID1,ID2,ID)
C FORM ID OUT OF ID1,ID2 BUT USING REFLECTED VALUES SO THAT
C RESULT ID IS ALWAYS IN PRIME AREA.
	InTeGer*4 ID,ID1,ID2,IDD1,IDD2
C ***<<< NULETC COMMON START >>>***
	InTeGer*4 ICREF,IRREF
C	COMMON/MIRROR/ICREF,IRREF
	InTeGer*4 MODPUB,LIMODE
C	COMMON/MODPUB/MODPUB,LIMODE
	InTeGer*4 KLKC,KLKR
	REAL*8 AACP,AACQ
C	COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
	InTeGer*4 NCEL,NXINI
C	COMMON/NCEL/NCEL,NXINI
	CHARACTER*1 NAMARY(20,301)
C	COMMON/NMNMNM/NAMARY
	InTeGer*4 NULAST,LFVD
C	COMMON/NULXXX/NULAST,LFVD
	COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC	COMMON/MIRROR/ICREF,IRREF
C IN RECALC WE MOVE OVER PRIME AREA ONLY AND SEARCH FOR CELLS IN
C DISPLAY AREA THERE. THIS IMPLIES THAT WE DON'T FIND DISPLAY
C COORDS OF CELLS IN EXTENDED AREAS THERE.  THEREFORE THE RI AND RE
C MODES FAIL COMPLETELY THERE. SINCE WE WANT THE SYSTEM TO WORK IN
C A PREDICTABLE WAY, FORCE RECALC MODE (I.E., R OR RM MODES) THERE TO
C ALLOW CELLS TO BE COMPUTED.
C NOTE THAT IF WE ARE IN THE PRIME AREA AND ISSUE AN RE OR RI COMMAND,
C THAT MODE SHOULD STAY SET SO LONG AS WE STAY THERE SINCE THE RE OR
C RI MODES WILL INHIBIT COMPUTING OUTSIDE THAT AREA (AS LONG AS NOTHING
C REFLECTS INTO IT) SO THERE WILL BE NO REASON FOR THIS TO BE CALLED
C TO REFLECT SOMETHING BACK TO PRIME AREA UNTIL A R COMMAND IS GIVEN
C OR THE DISPLAY MOVES OFF THE EDGE OF THE PRIME 60 BY 301 AREA.
C
C ***<<< XVXTCD COMMON START >>>***
	CHARACTER*1 OARRY(100)
	InTeGer*4 OSWIT,OCNTR
C	COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
	InTeGer*4 IPS1,IPS2,MODFLG
C	COMMON/ICPOS/IPS1,IPS2,MODFLG
   	InTeGer*4 XTCFG,IPSET,XTNCNT
   	CHARACTER*1 XTNCMD(80)
C   	COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
	INTEGER KALKIT
C	COMMON/VARYIT/KALKIT
	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
	InTeGer*4 RCMODE,IRCE1,IRCE2
C	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
	INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C	COMMON/CONSFH/FH
	CHARACTER*1 ARGSTR(52,4)
C	COMMON/ARGSTR/ARGSTR
	COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC	InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE
CCC	InTeGer*4 IRCE1,IRCE2
CCC	COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,IRCE2
	IDD1=MAX0(ID1,1)
	IDD2=ID2
C ACCEPT TRICK CALLS WITH ID1=0 AS FROM GMSUBS, MTXEQU,
C AND MDST
	IF(ID1.LT.1)GOTO 2000
4000	CONTINUE
	IF(IDD2.LE.60)GOTO 1000
	IDD2=IDD2-60
	IDD1=IDD1+IRREF
c	RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
	GOTO 4000
1000	CONTINUE
	IF(IDD1.LE.301)GOTO 2000
	IDD1=IDD1-300
	IDD2=IDD2+ICREF
c	RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
	GOTO 4000
2000	CONTINUE
	ID=(IDD1-1)*60+IDD2
	RETURN
	END
c -h- relvbl.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC)
C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN
C	PARAMETER CUP=1,ED=11,EL=12
	CHARACTER*1 NAME(4),NUMBER(6)
	CHARACTER*1 LNIN,LNOUT
	CHARACTER*6 NUMBR6
	EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
	DIMENSION LNIN(128),LNOUT(128)
C ***<<<< RDD COMMON START >>>***
	InTeGer*4 RRWACT,RCLACT
C	COMMON/RCLACT/RRWACT,RCLACT
	InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C	common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
	InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C	COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
	InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C	COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
	InTeGer*4 KLVL
C	COMMON/KLVL/KLVL
	InTeGer*4 IOLVL,IGOLD
C	COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
	COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC	InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC	COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
C	LOGICAL*2 L63,L192,L255,L127,L128
	LOGICAL*4 L1,L2
C	InTeGer*4 I63,I192,I255,I127,I128
	InTeGer*4 I63,I192,I127
	InTeGer*4 I1,I2
C	EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
	EQUIVALENCE (I1,L1),(I2,L2)
C	EQUIVALENCE (L127,I127),(L128,I128)
C	DATA I63/63/,I192/192/,I255/255/,I127/127/,I128/128/
	DATA I63/63/,I192/192/,I127/127/
	LI=1
	LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100	CONTINUE
C	IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200
	LCC=ICHAR(LNIN(LI))
C IF WE HAVE 255,CODE,CODE THEN RELOCATE IN BINARY...
	IF(LCC.EQ.255)GOTO 500
	IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
	IL1=LI
	LE=110
	LSTC=LE
	CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
C AVOID MESSING UP FUNCTION NAMES
	IF(ID2.EQ.1)IVLD=0
C	IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0
	IF(IVLD.EQ.0)GOTO 200
C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT.
C FIRST DON'T RELOCATE P## AND D## FORMS.
	IF(LNIN(LI+1).EQ.'#')GOTO 250
C RELOCATE NORMAL VARIABLE HERE.
C
C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS
C ID1.GT.JRTR AND ID2.GT.JRTC
	IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210
	IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210
C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL.
C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH
C AND CLAMP TO VALID DIMENSIONS.
	IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
	IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
906	ID1=MAX0(ID1,1)
	ID2=MAX0(ID2,1)
C CAN UNPACK THIS STUFF ALL RIGHT IN EXTENDED WAYS.
	ID1=MIN0(18060,ID1)
	ID2=MIN0(18060,ID2)

210	CONTINUE
	CALL IN2AS(ID1,NAME)
C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
	IL2=ID2-1
	WRITE(NUMBR6(1:6),1000)IL2
C	ENCODE(6,1000,NUMBER)IL2
1000	FORMAT(I6)
C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
C THROW OUT SPACES AND COPY THE REST.
	LI=LSTC
	DO 202 N=1,4
	IF(Ichar(NAME(N)).LE.32)GOTO 202
	LNOUT(LO)=NAME(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
202	CONTINUE
	IF(IDOL1.GT.0)LNOUT(LO)=36
	IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1
	DO 203 N=1,6
	IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
C IF 32 ISN'T SPACE, LOSE
	LNOUT(LO)=NUMBER(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
203	CONTINUE
	IF(IDOL2.EQ.0)GOTO 300
	LNOUT(LO)=CHAR(36)
	IF(LO.LE.109)LO=LO+1
	GOTO 300
250	CONTINUE
C JUST COPY DISPLAY FORMS.
	IL1=LSTC-1
	DO 251 N=LI,IL1
	LNOUT(LO)=LNIN(N)
	LO=LO+1
	IF(LO.GT.110)GOTO 300
251	CONTINUE
	LI=LSTC
C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
	GOTO 300
200	LNOUT(LO)=LNIN(LI)
	LO=LO+1
	LI=LI+1
300	IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
	LO=MIN0(LO,110)
	DO 400 N=LO,110
400	LNOUT(N)=0
	DO 1 N=111,128
1	LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
	RETURN
500	CONTINUE
C DECODE BY HAND...
	LNOUT(LO)=LNIN(LI)
	I1=ICHAR(LNIN(LI+1))
	I2=IMASK(I1,I192)
C	L2=L1.AND.L192
	I1=IMASK(I1,I63)
C	L1=L1.AND.L63
C DO MASKING TO GET BINARY COORDS
	ID1=I1
	I1=ICHAR(LNIN(LI+2))
	I1=IMASK(I1,I127)
C	L1=L1.AND.L127
	ID2=I2*2+I1
C NOW RELOCATE AND PUT BACK
	IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 510
	IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 510
	IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
	IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
C CLAMP RESULT TO MAX RANGES
	ID1=MAX0(ID1,1)
	ID2=MAX0(ID2,1)
C DO GENERAL REPACK IF ID1 OR ID2 ARE EXTENDED RANGE.
	IF(ID1.GT.60.OR.ID2.GT.301)GOTO 905
C	ID1=MIN0(60,ID1)
C	ID2=MIN0(301,ID2)
510	CONTINUE
C RELOCATED, NOW REPACK AS NEW BINARY PATTERNS
	I1=ID1
C	L1=L1.AND.L63
	I1=IMASK(I1,I63)
	I2=ID2/2
	I2=IMASK(I2,I192)
C	L2=L2.AND.L192
C	L1=L1.OR.L2
	I1=I1+I2
	LNOUT(LO+1)=CHAR(I1)
	I2=ID2
	I2=IMASK(I2,I127)+128
C	L2=L2.AND.L127
C	L2=L2.OR.L128
C BE SURE AT LEAST 1 BIT IS SET
	LNOUT(LO+2)=CHAR(I2)
	LI=MIN0(109,LI+3)
	LO=MIN0(109,LO+3)	
C GO LOOK FOR MORE TO DECODE
	GOTO 300
905	CONTINUE
C HERE SET UP FOR REENTRY INTO "NORMAL" DECODE
	LSTC=MIN0(109,LI+3)
	GOTO 906
	END
c -h- rnd.for	Tue Sep  2 10:58:55 1986	
	FUNCTION RND(DUM)
C GENERATE RANDOM NUMBER BY LINEAR CONGRUENCE IN BIG
C INTEGERS.
	REAL*4 R
	INTEGER*4 DUM
	INTEGER*4 I,II
	LOGICAL*4 L,LMSK
	REAL*8 XX
	EQUIVALENCE(I,L),(II,LMSK)
	I=DUM
	XX=I
	XX=XX*214013.0D0+2531011.0D0
	IF(XX.LT.0.)XX=1.0D0-XX
	XX=DMOD(XX,16777216.0D0)
	I=IDINT(XX)
C	I=I*214013+2531011
C USE MASKING TO ZOT THIS INTO NORMAL RANGE
C JUST USE MODULO...
	IF(I.LT.0)I=1-I
	IF(I.LT.0)I=0
	I=MOD(I,16777215)
	DUM=I
C RETURN RANDOM BETWEEN 0 AND 1.0
C PERIOD OF 2**24 MAX
	XX=I
	XX=XX/16777216.0
	R=SNGL(XX)
	RND=R
	RETURN
	END
c -h- rvboo.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE RVBOO(RETV,ID1,ID2)
C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
C ACCESS VARIABLE LOCATION LATER.
	InTeGer*4 RETV,ID1,ID2
	DIMENSION RETV(2)
	RETV(1)=ID1
	RETV(2)=ID2
	RETURN
	END
c -h- scmp.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SCMP(LINA,LINB,LENM,ICODE)
	DIMENSION LINA(1),LINB(1)
	CHARACTER*1 LINA,LINB
	ICODE=1
	DO 1 N=1,LENM
	IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
C ALLOW _ TO BE A WILDCARD.
	IF(LINA(N).EQ.'_'.OR.LINB(N).EQ.'_')GOTO 1
	IF(LINA(N).NE.LINB(N))ICODE=0
	IF(ICODE.NE.1)GOTO 2
1	CONTINUE
2	CONTINUE
	RETURN
	END
c -h- sed.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH)
	CHARACTER*1 LIN(1),LWRK(1),ARGSTR(52,4)
	CHARACTER*1 LCMD(1),LSU(10)
	EXTERNAL INDX
	CHARACTER*10 LSU10
	EQUIVALENCE (LSU10(1:10),LSU(1))
	INTEGER*4 III
	REAL*8 XAC
C
C OPERATION:
C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT
C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH
C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT.
C
C EDITS:
C  CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST
C INTERVAL BETWEEN DELIMITERS WITH SECOND.
C  HOWEVER:
C  &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4)
C
C  &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND
C  PRINTED.
C  &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND
C  INSERTED.
C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH
C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %).
C	WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER
C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER.
	DO 335 IV=1,80
335	LWRK(IV)=0
	IDELIM=ICHAR(LCMD(1))
	ID2=INDX(LCMD(2),IDELIM)
	IF(ID2.GE.LENGTH)GOTO 100
C NOW HAVE 1ST STRING, OF NONZERO LENGTH
C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT
C BOTH MUST BE DEFINED BY A DELIMITER.
	ID3=INDX(LCMD(2+ID2),IDELIM)
	IF(ID3.GE.LENGTH)GOTO 100
C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN.
C (NOTE WE WANT TO FILL ALL OF LENGTH)
	INLIN=1
	INWRK=1
	IVV=ID3+ID2+2
	DO 336 IV=IVV,LENGTH
336	LCMD(IV)=0
	LSA=ID2-1
	LSB=ID3-1
	LSSB=2+ID2
	LZR=0
	DO 1 N=1,LENGTH
	IF(LSA.GT.0)GOTO 350
C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO
C EXISTING STRING AT THE END.
C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.)
	IF(LIN(N).EQ.0)GOTO 351
C JUST COPY THE INPUT FIRST AND GO OFF
	GOTO 2
351	CONTINUE
C HERE WE HAVE THE TERMINAL NULL
	LZR=LZR+1
C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH
	IF(LZR.EQ.1)GOTO 222
	GOTO 1
350	CONTINUE
	IF(LIN(INLIN).EQ.0)GOTO 1
	CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD)
	IF(ICOD.EQ.0)GOTO 2
C HERE HAVE TO SUBSTITUTE
C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST.
222	CONTINUE
	INLIN=INLIN+LSA
C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER
	IF(LSB.LE.0)GOTO 1
C	DO 6 M=1,LSB
	M=1
106	CONTINUE
	IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7
8	CONTINUE
C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE.
	LWRK(INWRK)=LCMD(LSSB+M-1)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
	GOTO 6
7	CONTINUE
C HANDLE & FORMS
	IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8
C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE.
	M=M+1
	IF(LCMD(LSSB+M-1).GT.'4')GOTO 10
C HERE JUST HANDLE ARGSTR SUBSTITUTIONS.
	II=ICHAR(LCMD(LSSB+M-1))
	II=II-48
C II IS NOW THE INDEX.
	DO 11 MM=1,52
	LWRK(INWRK)=ARGSTR(MM,II)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
	IF(ARGSTR(MM,II).EQ.0)GOTO 12
11	CONTINUE
12	CONTINUE
	M=M+1
C PASS THE NUMBER OF THE &NUMBER FORM
	GOTO 6
10	CONTINUE
C HANDLE ZAC FORMS
	M=M+1
C PASS THE DIGIT
	IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14
C FILL IN ZAC AS AN INTEGER
	II=32
	IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC
C ONLY HANDLE CONVERSION IF LEGAL
	LWRK(INWRK)=CHAR(II)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
	GOTO 6
14	CONTINUE
C HANDLE NUMERIC CONVERSION HERE
	LSU(1)=0
	III=0
	IF(DABS(XAC).LT.9999999.)III=IDINT(XAC)
	WRITE(LSU10(1:10),15,ERR=22)III
C	ENCODE(10,15,LSU,ERR=22)III
15	FORMAT(I9)
22	DO 16 MK=1,10
	IF(LSU(MK).EQ.0)GOTO 6
	IF(LSU(MK).EQ.' ')GOTO 16
	LWRK(INWRK)=LSU(MK)
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
16	CONTINUE
6	CONTINUE
	M=M+1
	IF(M.LE.LSB)GOTO 106
	GOTO 1
2	CONTINUE
C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE.
	LWRK(INWRK)=LIN(INLIN)
	IF(INLIN.LT.LENGTH)INLIN=INLIN+1
	IF(INWRK.LT.LENGTH)INWRK=INWRK+1
1	CONTINUE
C COPY BACK OUT TO CMDLIN AFTER FIXUP
	IF(INWRK.GE.LENGTH)GOTO 3
	DO 4 N=INWRK,LENGTH
4	LWRK(N)=0
3	CONTINUE
C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW.
	DO 5 N=1,LENGTH
5	LCMD(N)=LWRK(N)
100	CONTINUE
	RETURN
	END
c -h- sign.for	Tue Sep  2 10:58:55 1986	
	REAL *8 FUNCTION SIGN(VAR)
	REAL*8 VAR
C ALWAYS RETURN 1. OR -1. FOR THIS PROGRAM ... NEVER 0.
	SIGN=1.
	IF(VAR.LT.0.)SIGN=-1.
	RETURN
	END
c -h- slend.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SLEND(RETCD)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *         SUBROUTINE   SLEND(RETCD)              *
C *                                                *
C **************************************************
C
C
C
C SETS VALUE OF LEND, POINTER TO LAST NON-BLANK CHARACTER
C IN LINE(80)
C
C
C
C
C RETCD VALUE       MEANING
C
C    1            NORMAL RETURN
C    2            ALL BLANKS
C
C
C
C   SLEND IS CALLED BY CALC
C
C VARIABLE    USE
C
C  BLANK      ' '
C    I        INDEXES CHARACTERS IN LINE(80).
C  LEND       UPON EXIT, POINTS TO THE LAST NON-
C             BLANK IN LINE(80).
C  LINE(80)   HOLDS COMMAND LINE.
C  RETCD      RETURN CODE.  1=NORMAL, 2=ALL BLANKS
C
C
C
C	SUBROUTINE SLEND(RETCD)
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4 VIEWSW,BASED,RETCD
C
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	CHARACTER*1 LINE(80)
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
C
C
C
	RETCD=1
	DO 100 I=1,80
	IF(LINE(81-I).NE.BLANK)GO TO 200
100	CONTINUE
	RETCD=2
	RETURN
200	LEND=81-I
	RETURN
	END
c -h- sscmp.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE)
	DIMENSION LINA(1),LINB(1)
	CHARACTER*1 LINA,LINB
	ICODE=1
	DO 1 N=1,LENM
c	IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
	IF(ICHAR(LINA(N)).NE.ICHAR(LINB(N)))ICODE=0
	IF(ICODE.NE.1)GOTO 2
1	CONTINUE
2	CONTINUE
	RETURN
	END
c -h- sstr.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM)
	CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
	InTeGer*4 LA,N,LE
	InTeGer*4 VLEN(9),TYPE(1,1)
	CHARACTER*1 AVBLS(20,27)
	REAL*8 XVBLS(1,1),XX,VP,TMP
	COMMON/V/TYPE,AVBLS,XVBLS,VLEN
	NI=N
	N=N+2
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
	LAA=N
	LEE=LE
	CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
	IF(IVLD.LE.0)GOTO 990
C	XX=XVBLS(I1,I2)
	CALL XVBLGT(I1,I2,XX)
	VP=128.D0**7
	DO 1 NN=1,8
	TMP=DINT(XX/VP)
	NBF(NN)=CHAR(IDINT(TMP))
	VP=VP/128.D0
	XX=XX-(128.D0*TMP)
1	CONTINUE
C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED
C STRING. COPY TO FORM.
	NL=NI
	DO 2 NN=1,8
	FORM(NL)=NBF(NN)
	IF(NN.GE.1)NL=NL+1
2	CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
	N=NL
	LE=LE-LSTC+NL
	DO 401 M=N,LE
	CMDLIN(M)=CMDLIN(M+LSTC-NL)
401	CONTINUE
C HOPE ALL'S WELL NOW...
	RETURN
990	FORM(N)=CMDLIN(N)
	RETURN
	END
c -h- strcmp.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *   SUBROUTINE STRCMP(NAME,LENGTH,RETCD)         *
C *                                                *
C **************************************************
C
C
C  STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH)
C  THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE:
C
C	1=MATCH
C	2=FAILURE
C
C  UPON EXIT, COMMON VARIABLE NONBLK
C         IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED
C                 FOR MATCH
C         IF FAILURE, UNCHANGED
C
C
C
C  MODIFICATION CLASSES: M2
C
C
C
C  STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80)
C
C  STRCMP IS CALLED BY CMND
C
C
C
C
C VARIABLE       USE
C
C   I2        INDEXES NAME(LENGTH).
C   IS        HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS
C             AND IT IS NECESSARY TO RESTORE THE VALUE.
C   LENGTH    HOLDS THE LENGTH OF VECTOR NAME.
C   NONBLK    POINTER FOR COMMAND LINE HELD BY LINE(80).
C   RETCD     HOLDS RETURN CODE.  1=MATCH,  2=FAILURE
C
C
C
C
C	SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
	InTeGer*4 LENGTH
	InTeGer*4 LEVEL,NONBLK,LEND
	InTeGer*4  RETCD,VIEWSW,BASED
C
	CHARACTER*1  LINE(80),NAME(LENGTH)
	CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER
C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER
C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER
C IN THE COMMAND NAME (AFTER THE ASTERISK).
	IS=NONBLK
	CALL GETNNB(IPT,RETCD)
	GO TO (10,999),RETCD
C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME
C
C
10	DO 100 I2=1,LENGTH
	CALL GETNNB(IPT,RETCD)
	GO TO (20,999),RETCD
	STOP 20
20	NONBLK=IPT
	IF(NAME(I2).NE.LINE(NONBLK))GOTO 999
100	CONTINUE
	RETCD=1
	RETURN
C
C
C NO MATCH
999	RETCD=2
C IF ERROR, RESTORE VALUE OF NONBLK
	NONBLK=IS
	RETURN
	END
c -h- svbl.for	Tue Sep  2 10:58:55 1986	
	SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM)
	InTeGer*4 VLEN(9),TYPE(1,1)
	CHARACTER*1 AVBLS(20,27)
	REAL*8 XVBLS(1,1)
	COMMON/V/TYPE,AVBLS,XVBLS,VLEN
	CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
	CHARACTER*3 NBF3
	EQUIVALENCE(NBF3(1:1),NBF(5))
	InTeGer*4 LA,N,LE
	NI=N
	N=N+2
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
	LAA=N
	LEE=LE
	CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
	IF(IVLD.LE.0)GOTO 990
	LAA=LSTC+1
C ACCEPT ANY DELIMITER
	LEE=LE
	CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD)
	IF(IVLD.LE.0)GOTO 990
C	XX=XVBLS(I1,I2)
	CALL XVBLGT(I1,I2,XX)
C XX IS COL #
C	XY=XVBLS(J1,J2)-1.0
	CALL XVBLGT(J1,J2,XY)
	IF(XX.LE..99.OR.XX.GT.DFLOAT(RRW))GOTO 990
	IF(XY.LE..99.OR.XY.GT.DFLOAT(RCL))GOTO 990
	IC=XX
	CALL IN2AS(IC,NBF)
	IR=XY
	WRITE(NBF3(1:3),300)IR
C	ENCODE(3,300,NBF(5))IR
300	FORMAT(BZ,I3)
	NL=NI
C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES.
	DO 400 NN=1,7
	FORM(NL)=NBF(NN)
	IF(FORM(NL).GT.64)NL=NL+1
400	CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
	N=NL
	LE=LE-LSTC+NL
	DO 401 M=N,LE
	CMDLIN(M)=CMDLIN(M+LSTC-NL)
401	CONTINUE
C HOPE ALL'S WELL NOW...
	RETURN
990	CONTINUE
	FORM(N)=CMDLIN(N)
	RETURN
	END
c -h- swrt.for	Tue Sep  2 10:58:55 1986	
C
C SWRT - WRITE VARIABLE LENGTH STRING TO SCREEN WITHOUT
C RECORD TERMINATION.
C COPYRIGHT GLENN C EVERHART 1984
C ALL RIGHTS RESERVED
C *** Don't use for normal Amiga stuff, but have available in case
C *** it should be handy someplace...
C
C
ccc	SUBROUTINE SWRT(STRING,LENGTH)
ccc	CHARACTER*1 STRING(127)
ccc	INTEGER LENGTH
cccC DUMP OUT ALL WE CAN..
ccc	CHARACTER*9 SFM
ccc	CHARACTER*1 SFMX(9)
ccc	CHARACTER*3 SNM
ccc	EQUIVALENCE(SNM,SFMX(2))
ccc	EQUIVALENCE (SFMX(1),SFM)
cccC HERE ARE THE BUILT IN FORMATS. NOTE WE FILL IN THE
cccC REPEAT COUNT AT RUNTIME FOR THE TEXT TO BE WRITTEN.
cccC NOTE ALSO THAT THE 1ST CHAR IS A # SIGN TO SHOW UP PROBLEMS.
cccC FORMATS ARE (nnnA1,\)
cccC COMPRISING 13 CHARACTERS IN ALL.
ccc	DATA SFM/'(001A1,\)'/
cccC NOTE WE JUST FILL IN THE LENGTH AND WRITE TO SCREEN USING
cccC SFM AS A RUNTIME FORMAT.
cccC
ccc	IF(LENGTH.LE.0)RETURN
ccc	WRITE(SNM,1)LENGTH
ccc1	FORMAT(BZ,I3)
cccC WRITE ON UNIT 6 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
cccC (VIA EXPLICIT OPEN IN MAIN PROGRAM)
ccc	WRITE(11,SFM)(STRING(II),II=1,LENGTH)
ccc	RETURN
ccc	END
	SUBROUTINE VWRT(STRING,LENGTH)
C VWRT is like SWRT but writes to lun 11 window instead.
	CHARACTER*1 STRING(127)
	INTEGER LENGTH
C DUMP OUT ALL WE CAN..
	IF(LENGTH.LE.0)RETURN
C WRITE ON UNIT 11 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
C (VIA EXPLICIT OPEN IN MAIN PROGRAM)
	WRITE(18,777)(STRING(II),II=1,LENGTH)
777	format(1X,127A1)
	RETURN
	END
